perm filename NEWLAP[LAP,SYS] blob
sn#010438 filedate 1973-07-03 generic text, type T, neo UTF8
00100 (PROG (SEXPR IBASE)
00200 (SETQ IBASE (ADD1 7))
00300 LOOP (SETQ SEXPR (ERRSET (READ)))
00400 (COND ((EQ SEXPR (QUOTE $EOF$)) (ERR)))
00500 (PRINT (EVAL (CAR SEXPR)))
00600 (GO LOOP))
00700
00800 (DECLARE (SPECIAL BPEND BPORG KLIST QLIST)
00900 (SPECIAL CONLIST GEN LOC REMOB)
01000 (DEFPROP LAPERR T *FSUBR))
01100
01200 (DEFPROP DFUNC
01300 (LAMBDA (L)
01400 (LIST (Q DEFPROP)
01500 (CAADR L)
01600 (MCONS (Q LAMBDA) (CDADR L) (CDDR L))
01700 (Q EXPR)))
01800 MACRO)
01900
02000 (DEFPROP ISTAG (LAMBDA (L) (CONS (Q ISIDENT) (CDR L))) MACRO)
02100
02200 (DEFPROP MAPDEF
02300 (LAMBDA (L)
02400 (LIST (Q MAPCAR)
02500 (SUBST (CADR L)
02600 (Q IND)
02700 (Q (FUNCTION (LAMBDA (PAIR)
02800 (PUTPROP
02900 (CAR PAIR)
03000 (CADR PAIR)
03100 (QUOTE IND))))))
03200 (LIST (Q QUOTE) (CDDR L))))
03300 MACRO)
03400
03500 (DEFPROP MCONS
03600 (LAMBDA (L)
03700 (COND ((NULL (CDDR L)) (CADR L))
03800 (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
03900 MACRO)
04000
04100 (DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)
04200
04300 (DEFPROP RET (LAMBDA (L) (CONS (Q RETURN) (CDR L))) MACRO)
04400
04500 (DEFPROP FIRSTPROP (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
04600
04700 (DEFPROP LASTPROP (LAMBDA (L) (CONS (Q NULL) (CDR L))) MACRO)
04800
04900 (DEFPROP NEXTPROP (LAMBDA (L) (CONS (Q CDDR) (CDR L))) MACRO)
05000
05100 (DEFPROP PROPNAM (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)
05200
05300 (DEFPROP PROPTABLE (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
05400
05500 (DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CADR) (CDR L))) MACRO)
05600
05700 (DFUNC (DELETEPROP IDENT PROPNAM)
05800 (PROG (TEM)
05900 (SETQ TEM IDENT)
06000 LOOP (COND ((NULL (CDR TEM)) (RET NIL)))
06100 (COND ((EQ (CADR TEM) PROPNAM) (RPLACD TEM (CDDDR TEM))
06200 (RET T)))
06300 (SETQ TEM (CDDR TEM))
06400 (GO LOOP)))
06500
06600 (DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP)))
06700
06800 (DFUNC (INITPROP IDENT PROPNAM PROPVAL)
06900 (RPLACD IDENT (MCONS PROPNAM PROPVAL (CDR IDENT))))
07000
07100 (DFUNC (SEEKPROP IDENT PROPNAM)
07200 (PROG (TEM)
07300 (SETQ TEM (GETL IDENT (LIST PROPNAM)))
07400 (COND ((NULL TEM) (RET NIL)))
07500 (RET TEM)))
07600
07700 (DFUNC (SETPROP IDENT PROPNAM PROPVAL) (PUTPROP IDENT PROPVAL PROPNAM))
07800
07900 (DFUNC (ASSARGS OPCODE ARGS)
08000 (PROG (FIELDS WORD)
08100 (SETQ FIELDS (Q ((27 . 17) (0 . 777777) (22 . 777777))))
08200 (SETQ WORD (LSH OPCODE 22))
08300 LOOP (COND ((OR (NULL FIELDS) (NULL ARGS))
08400 (RETURN WORD)))
08500 (SETQ WORD
08600 (PLUS WORD
08700 (LSH (BOOLE 1
08800 (CDAR FIELDS)
08900 (LAPEVAL (CAR ARGS) LOC))
09000 (CAAR FIELDS))))
09100 (SETQ ARGS (CDR ARGS))
09200 (SETQ FIELDS (CDR FIELDS))
09300 (GO LOOP)))
09400
09500 (DFUNC (ASSINST INST)
09600 (PROG NIL
09700 (LAPDEPOSIT LOC
09800 (ASSARGS (GET (CAR INST) (Q OPCODE)) (CDR INST)))
09900 (SETQ LOC (ADD1 LOC))))
10000
10100 (DFUNC (CONSTANTADDR SYM LOC)
10200 (PROG (N CPTR)
10300 (SETQ CPTR KLIST)
10400 L11 (COND ((NULL CPTR) (GO L12))
10500 ((EQUAL (CDR SYM) (CAAR CPTR)) (RET (CDAR CPTR))))
10600 (SETQ CPTR (CDR CPTR))
10700 (GO L11)
10800 L12 (GVAL GEN LOC)
10900 (SETQ N 0)
11000 (SETQ CPTR CONLIST)
11100 A (COND ((NULL (CDR CPTR)) (RPLACD CPTR (LIST (CDR SYM)))))
11200 (COND ((EQUAL (CDR SYM) (CADR CPTR)) (RET N)))
11300 (SETQ N (ADD1 N))
11400 (SETQ CPTR (CDR CPTR))
11500 (GO A)))
11600
11700 (DFUNC (DEFLOC TAG LOC)
11800 (PROG (TEM)
11900 (SETQ REMOB (CONS TAG REMOB))
12000 (COND ((SETQ TEM (GET TAG (Q UNDEF))) (GO PATCH)))
12100 RET (RET (PUTPROP TAG LOC (Q TAG)))
12200 PATCH(COND ((NULL TEM) (RPLACD TAG (CDDDR TAG)) (GO RET)))
12300 (LAPDEPOSIT (CAR TEM) (PLUS (EXAMINE (CAR TEM)) LOC))
12400 (SETQ TEM (CDR TEM))
12500 (GO PATCH)))
12600
12700 (DEFPROP DEFSYM (LAMBDA (SYM VAL) (PUTPROP SYM VAL (QUOTE SYM))) EXPR)
12800
12900 (DFUNC (DOPSEUDOOP SYM LOC) ((GET (CAR SYM) (Q PSEUDOOP)) SYM LOC))
13000
13100 (DFUNC (GETGET ATOM PROP)
13200 (PROG (TEM PTAB)
13300 (SETQ PTAB (FIRSTPROP ATOM))
13400 LOOP (COND ((LASTPROP PTAB) (RET NIL)))
13500 (COND ((SETQ TEM (SEEKPROP (PROPNAM PTAB) PROP)) (RET TEM)))
13600 (SETQ PTAB (NEXTPROP PTAB))
13700 (GO LOOP)))
13800
13900 (DFUNC (GVAL SYM LOC)
14000 (COND ((GET SYM (Q TAG)))
14100 ((GET SYM (Q SYM)))
14200 ((GET SYM (Q VALUE)) (MAKNUM SYM (Q FIXNUM)))
14300 (T (PUTPROP SYM (CONS LOC (GET SYM (Q UNDEF))) (Q UNDEF)) 0)))
14400
14500 (DFUNC (ISIDENT EX) (AND (ATOM EX) (NOT (NUMBERP EX))))
14600
14700 (DEFPROP LAP
14800 (LAMBDA (SL)
14900 (PROG (LOC CONLIST GEN REMOB L)
15000 (SETQ GEN (GENSYM))
15100 (SETQ CONLIST (LIST NIL))
15200 (SETQ LOC BPORG)
15300 A (COND ((NULL (SETQ L (READ))) (GO END)))
15400 (LAPEXPR L)
15500 (GO A)
15600 END (DEFLOC GEN LOC)
15700 CONST(COND ((NULL (SETQ CONLIST (CDR CONLIST)))
15800 (EVAL (CONS (Q REMOB) REMOB))
15900 (PUTPROP (CAR SL) (NUMVAL BPORG) (CADR SL))
16000 (RET (LIST BPORG (CAR SL) (SETQ BPORG LOC)))))
16100 (SETQ KLIST (CONS (CONS (CAR CONLIST) LOC) KLIST))
16200 (LAPEXPR (CAR CONLIST))
16300 (GO CONST)))
16400 FEXPR)
16500
16600 (DFUNC (LAPDEPOSIT LOC WORD)
16700 (COND ((GREATERP LOC BPEND) (LAPERR BINARY PROGRAM SPACE EXCEEDED))
16800 (T (DEPOSIT LOC WORD))))
16900
17000 (DEFPROP LAPERR (LAMBDA (L) (PROG2 (PRINT L) (ERR))) FEXPR)
17100
17200 (DFUNC (LAPEVAL EXPR LOC)
17300 (PROG (TEM)
17400 (COND ((NUMBERP EXPR) (RETURN EXPR)))
17500 (COND ((ISIDENT EXPR) (RETURN (GVAL EXPR LOC))))
17600 (SETQ TEM (GETGET (CAR EXPR) (Q ADDRESSPROP)))
17700 (COND ((NULL TEM) (LAPERR UNDEFINED PSEUDO OP)))
17800 (RETURN ((PROPVAL TEM) EXPR LOC))))
17900
18000 (DFUNC (LAPEXPR EXPR)
18100 (COND ((ISTAG EXPR) (DEFLOC EXPR LOC))
18200 ((NUMBERP EXPR) (LAPERR NUMERIC TAG))
18300 ((NUMBERP (CAR EXPR))
18400 (LAPDEPOSIT LOC (ASSARGS (CAR EXPR) (CDR EXPR)))
18500 (SETQ LOC (ADD1 LOC)))
18600 (T (PROG (TEM)
18700 (COND ((SETQ TEM (GETGET (CAR EXPR) (Q WORDPROP)))
18800 (RET ((PROPVAL TEM) EXPR)))
18900 (T (LAPERR (UNDEFINED OPCODE))))))))
19000
19100 (DFUNC (QUOTEADDR SYM LOC)
19200 (MAKNUM (COND ((OR (NOT (ATOM (SETQ SYM (CADR SYM))))
19300 (AND (NUMBERP SYM) (NOT (EQ (PLUS SYM 0) SYM)))
19400 (EQ (CAR (EXPLODE SYM)) (Q /")))
19500 (PROG (Y)
19600 (SETQ Y QLIST)
19700 A (COND ((NULL Y)
19800 (RET (CAR (SETQ QLIST
19900 (CONS SYM QLIST)))))
20000 ((AND (EQUAL SYM (CAR Y))
20100 (EQ (TYPE SYM) (TYPE (CAR Y))))
20200 (RET (CAR Y))))
20300 (SETQ Y (CDR Y))
20400 (GO A)))
20500 (T SYM))
20600 (Q FIXNUM)))
20700
20800 (DFUNC (SPECIALADDR SYM LOC)
20900 (PROG NIL
21000 (COND ((NULL (GET (CADR SYM) (Q VALUE)))
21100 (PUTPROP (CADR SYM) (LIST NIL) (Q VALUE))))
21200 (RETURN (MAKNUM (GET (CADR SYM) (Q VALUE)) (Q FIXNUM)))))
21300
21400 (DEFPROP TYPE (LAMBDA (X) (COND ((NUMBERP X) (CADR X)))) EXPR)
21500
21600 (MAPDEF ADDRESSPROP (PSEUDOOP DOPSEUDOOP))
21700
21800 (MAPDEF WORDPROP (OPCODE ASSINST))
21900
22000 (MAPDEF SYM (A 1) (B 2) (C 3) (P 14))
22100
22200 (MAPDEF OPCODE
22300 (ADD 270000) (CALL 34000) (CALLF 36000) (CALLF@ 36020) (CAIE 302000)
22400 (CAIN 306000) (CAME 312000) (CAMN 316000) (CLEARB 403000)
22500 (CLEARM 402000) (DPB 137000) (EXCH 250000) (HLLZS@ 513020)
22600 (HLRZ 554000) (HLRZ@ 554020) (HRLM 506000) (HRLM@ 506020) (HRRM 542000)
22700 (HRRZS@ 553020) (HRRZ 550000) (HRRM@ 542020) (HRRZ@ 550020)
22800 (JCALL 35000) (JCALLF 37000) (JCALLF@ 37020) (JRST 254000) (JSP 265000)
22900 (JUMPE 322000) (JUMPN 326000) (MOVE 200000) (MOVEI 201000)
23000 (MOVEM 202000) (MOVNI 211000) (POP 262000) (POPJ 263000) (PUSH 261000)
23100 (PUSHJ 260000) (SOJE 362000) (SOJN 366000) (SUB 274000) (TDZA 634000))
23200
23300 (MAPDEF PSEUDOOP
23400 (C CONSTANTADDR) (CONSTANT CONSTANTADDR) (E QUOTEADDR)
23500 (FUNCTION QUOTEADDR) (QUOTE QUOTEADDR) (SPECIAL SPECIALADDR))
23600
23700 (COND ((NULL (GET (QUOTE QLIST) (Q VALUE))) (SETQ QLIST NIL)))
23800
23900 (COND ((NULL (GET (QUOTE KLIST) (Q VALUE))) (SETQ KLIST NIL)))
24000